home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / IO / String.pm
Text File  |  2005-12-05  |  11KB  |  552 lines
  1. package IO::String;
  2.  
  3. # Copyright 1998-2005 Gisle Aas.
  4. #
  5. # This library is free software; you can redistribute it and/or
  6. # modify it under the same terms as Perl itself.
  7.  
  8. require 5.005_03;
  9. use strict;
  10. use vars qw($VERSION $DEBUG $IO_CONSTANTS);
  11. $VERSION = "1.08";  # $Date: 2005/12/05 12:00:47 $
  12.  
  13. use Symbol ();
  14.  
  15. sub new
  16. {
  17.     my $class = shift;
  18.     my $self = bless Symbol::gensym(), ref($class) || $class;
  19.     tie *$self, $self;
  20.     $self->open(@_);
  21.     return $self;
  22. }
  23.  
  24. sub open
  25. {
  26.     my $self = shift;
  27.     return $self->new(@_) unless ref($self);
  28.  
  29.     if (@_) {
  30.     my $bufref = ref($_[0]) ? $_[0] : \$_[0];
  31.     $$bufref = "" unless defined $$bufref;
  32.     *$self->{buf} = $bufref;
  33.     }
  34.     else {
  35.     my $buf = "";
  36.     *$self->{buf} = \$buf;
  37.     }
  38.     *$self->{pos} = 0;
  39.     *$self->{lno} = 0;
  40.     return $self;
  41. }
  42.  
  43. sub pad
  44. {
  45.     my $self = shift;
  46.     my $old = *$self->{pad};
  47.     *$self->{pad} = substr($_[0], 0, 1) if @_;
  48.     return "\0" unless defined($old) && length($old);
  49.     return $old;
  50. }
  51.  
  52. sub dump
  53. {
  54.     require Data::Dumper;
  55.     my $self = shift;
  56.     print Data::Dumper->Dump([$self], ['*self']);
  57.     print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']);
  58.     return;
  59. }
  60.  
  61. sub TIEHANDLE
  62. {
  63.     print "TIEHANDLE @_\n" if $DEBUG;
  64.     return $_[0] if ref($_[0]);
  65.     my $class = shift;
  66.     my $self = bless Symbol::gensym(), $class;
  67.     $self->open(@_);
  68.     return $self;
  69. }
  70.  
  71. sub DESTROY
  72. {
  73.     print "DESTROY @_\n" if $DEBUG;
  74. }
  75.  
  76. sub close
  77. {
  78.     my $self = shift;
  79.     delete *$self->{buf};
  80.     delete *$self->{pos};
  81.     delete *$self->{lno};
  82.     undef *$self if $] eq "5.008";  # workaround for some bug
  83.     return 1;
  84. }
  85.  
  86. sub opened
  87. {
  88.     my $self = shift;
  89.     return defined *$self->{buf};
  90. }
  91.  
  92. sub binmode
  93. {
  94.     my $self = shift;
  95.     return 1 unless @_;
  96.     # XXX don't know much about layers yet :-(
  97.     return 0;
  98. }
  99.  
  100. sub getc
  101. {
  102.     my $self = shift;
  103.     my $buf;
  104.     return $buf if $self->read($buf, 1);
  105.     return undef;
  106. }
  107.  
  108. sub ungetc
  109. {
  110.     my $self = shift;
  111.     $self->setpos($self->getpos() - 1);
  112.     return 1;
  113. }
  114.  
  115. sub eof
  116. {
  117.     my $self = shift;
  118.     return length(${*$self->{buf}}) <= *$self->{pos};
  119. }
  120.  
  121. sub print
  122. {
  123.     my $self = shift;
  124.     if (defined $\) {
  125.     if (defined $,) {
  126.         $self->write(join($,, @_).$\);
  127.     }
  128.     else {
  129.         $self->write(join("",@_).$\);
  130.     }
  131.     }
  132.     else {
  133.     if (defined $,) {
  134.         $self->write(join($,, @_));
  135.     }
  136.     else {
  137.         $self->write(join("",@_));
  138.     }
  139.     }
  140.     return 1;
  141. }
  142. *printflush = \*print;
  143.  
  144. sub printf
  145. {
  146.     my $self = shift;
  147.     print "PRINTF(@_)\n" if $DEBUG;
  148.     my $fmt = shift;
  149.     $self->write(sprintf($fmt, @_));
  150.     return 1;
  151. }
  152.  
  153.  
  154. my($SEEK_SET, $SEEK_CUR, $SEEK_END);
  155.  
  156. sub _init_seek_constants
  157. {
  158.     if ($IO_CONSTANTS) {
  159.     require IO::Handle;
  160.     $SEEK_SET = &IO::Handle::SEEK_SET;
  161.     $SEEK_CUR = &IO::Handle::SEEK_CUR;
  162.     $SEEK_END = &IO::Handle::SEEK_END;
  163.     }
  164.     else {
  165.     $SEEK_SET = 0;
  166.     $SEEK_CUR = 1;
  167.     $SEEK_END = 2;
  168.     }
  169. }
  170.  
  171.  
  172. sub seek
  173. {
  174.     my($self,$off,$whence) = @_;
  175.     my $buf = *$self->{buf} || return 0;
  176.     my $len = length($$buf);
  177.     my $pos = *$self->{pos};
  178.  
  179.     _init_seek_constants() unless defined $SEEK_SET;
  180.  
  181.     if    ($whence == $SEEK_SET) { $pos = $off }
  182.     elsif ($whence == $SEEK_CUR) { $pos += $off }
  183.     elsif ($whence == $SEEK_END) { $pos = $len + $off }
  184.     else                         { die "Bad whence ($whence)" }
  185.     print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG;
  186.  
  187.     $pos = 0 if $pos < 0;
  188.     $self->truncate($pos) if $pos > $len;  # extend file
  189.     *$self->{pos} = $pos;
  190.     return 1;
  191. }
  192.  
  193. sub pos
  194. {
  195.     my $self = shift;
  196.     my $old = *$self->{pos};
  197.     if (@_) {
  198.     my $pos = shift || 0;
  199.     my $buf = *$self->{buf};
  200.     my $len = $buf ? length($$buf) : 0;
  201.     $pos = $len if $pos > $len;
  202.     *$self->{pos} = $pos;
  203.     }
  204.     return $old;
  205. }
  206.  
  207. sub getpos { shift->pos; }
  208.  
  209. *sysseek = \&seek;
  210. *setpos  = \&pos;
  211. *tell    = \&getpos;
  212.  
  213.  
  214.  
  215. sub getline
  216. {
  217.     my $self = shift;
  218.     my $buf  = *$self->{buf} || return;
  219.     my $len  = length($$buf);
  220.     my $pos  = *$self->{pos};
  221.     return if $pos >= $len;
  222.  
  223.     unless (defined $/) {  # slurp
  224.     *$self->{pos} = $len;
  225.     return substr($$buf, $pos);
  226.     }
  227.  
  228.     unless (length $/) {  # paragraph mode
  229.     # XXX slow&lazy implementation using getc()
  230.     my $para = "";
  231.     my $eol = 0;
  232.     my $c;
  233.     while (defined($c = $self->getc)) {
  234.         if ($c eq "\n") {
  235.         $eol++;
  236.         next if $eol > 2;
  237.         }
  238.         elsif ($eol > 1) {
  239.         $self->ungetc($c);
  240.         last;
  241.         }
  242.         else {
  243.         $eol = 0;
  244.         }
  245.         $para .= $c;
  246.     }
  247.     return $para;   # XXX wantarray
  248.     }
  249.  
  250.     my $idx = index($$buf,$/,$pos);
  251.     if ($idx < 0) {
  252.     # return rest of it
  253.     *$self->{pos} = $len;
  254.     $. = ++ *$self->{lno};
  255.     return substr($$buf, $pos);
  256.     }
  257.     $len = $idx - $pos + length($/);
  258.     *$self->{pos} += $len;
  259.     $. = ++ *$self->{lno};
  260.     return substr($$buf, $pos, $len);
  261. }
  262.  
  263. sub getlines
  264. {
  265.     die "getlines() called in scalar context\n" unless wantarray;
  266.     my $self = shift;
  267.     my($line, @lines);
  268.     push(@lines, $line) while defined($line = $self->getline);
  269.     return @lines;
  270. }
  271.  
  272. sub READLINE
  273. {
  274.     goto &getlines if wantarray;
  275.     goto &getline;
  276. }
  277.  
  278. sub input_line_number
  279. {
  280.     my $self = shift;
  281.     my $old = *$self->{lno};
  282.     *$self->{lno} = shift if @_;
  283.     return $old;
  284. }
  285.  
  286. sub truncate
  287. {
  288.     my $self = shift;
  289.     my $len = shift || 0;
  290.     my $buf = *$self->{buf};
  291.     if (length($$buf) >= $len) {
  292.     substr($$buf, $len) = '';
  293.     *$self->{pos} = $len if $len < *$self->{pos};
  294.     }
  295.     else {
  296.     $$buf .= ($self->pad x ($len - length($$buf)));
  297.     }
  298.     return 1;
  299. }
  300.  
  301. sub read
  302. {
  303.     my $self = shift;
  304.     my $buf = *$self->{buf};
  305.     return undef unless $buf;
  306.  
  307.     my $pos = *$self->{pos};
  308.     my $rem = length($$buf) - $pos;
  309.     my $len = $_[1];
  310.     $len = $rem if $len > $rem;
  311.     return undef if $len < 0;
  312.     if (@_ > 2) { # read offset
  313.     substr($_[0],$_[2]) = substr($$buf, $pos, $len);
  314.     }
  315.     else {
  316.     $_[0] = substr($$buf, $pos, $len);
  317.     }
  318.     *$self->{pos} += $len;
  319.     return $len;
  320. }
  321.  
  322. sub write
  323. {
  324.     my $self = shift;
  325.     my $buf = *$self->{buf};
  326.     return unless $buf;
  327.  
  328.     my $pos = *$self->{pos};
  329.     my $slen = length($_[0]);
  330.     my $len = $slen;
  331.     my $off = 0;
  332.     if (@_ > 1) {
  333.     $len = $_[1] if $_[1] < $len;
  334.     if (@_ > 2) {
  335.         $off = $_[2] || 0;
  336.         die "Offset outside string" if $off > $slen;
  337.         if ($off < 0) {
  338.         $off += $slen;
  339.         die "Offset outside string" if $off < 0;
  340.         }
  341.         my $rem = $slen - $off;
  342.         $len = $rem if $rem < $len;
  343.     }
  344.     }
  345.     substr($$buf, $pos, $len) = substr($_[0], $off, $len);
  346.     *$self->{pos} += $len;
  347.     return $len;
  348. }
  349.  
  350. *sysread = \&read;
  351. *syswrite = \&write;
  352.  
  353. sub stat
  354. {
  355.     my $self = shift;
  356.     return unless $self->opened;
  357.     return 1 unless wantarray;
  358.     my $len = length ${*$self->{buf}};
  359.  
  360.     return (
  361.      undef, undef,  # dev, ino
  362.      0666,          # filemode
  363.      1,             # links
  364.      $>,            # user id
  365.      $),            # group id
  366.      undef,         # device id
  367.      $len,          # size
  368.      undef,         # atime
  369.      undef,         # mtime
  370.      undef,         # ctime
  371.      512,           # blksize
  372.      int(($len+511)/512)  # blocks
  373.     );
  374. }
  375.  
  376. sub FILENO {
  377.     return undef;   # XXX perlfunc says this means the file is closed
  378. }
  379.  
  380. sub blocking {
  381.     my $self = shift;
  382.     my $old = *$self->{blocking} || 0;
  383.     *$self->{blocking} = shift if @_;
  384.     return $old;
  385. }
  386.  
  387. my $notmuch = sub { return };
  388.  
  389. *fileno    = $notmuch;
  390. *error     = $notmuch;
  391. *clearerr  = $notmuch; 
  392. *sync      = $notmuch;
  393. *flush     = $notmuch;
  394. *setbuf    = $notmuch;
  395. *setvbuf   = $notmuch;
  396.  
  397. *untaint   = $notmuch;
  398. *autoflush = $notmuch;
  399. *fcntl     = $notmuch;
  400. *ioctl     = $notmuch;
  401.  
  402. *GETC   = \&getc;
  403. *PRINT  = \&print;
  404. *PRINTF = \&printf;
  405. *READ   = \&read;
  406. *WRITE  = \&write;
  407. *SEEK   = \&seek;
  408. *TELL   = \&getpos;
  409. *EOF    = \&eof;
  410. *CLOSE  = \&close;
  411. *BINMODE = \&binmode;
  412.  
  413.  
  414. sub string_ref
  415. {
  416.     my $self = shift;
  417.     return *$self->{buf};
  418. }
  419. *sref = \&string_ref;
  420.  
  421. 1;
  422.  
  423. __END__
  424.  
  425. =head1 NAME
  426.  
  427. IO::String - Emulate file interface for in-core strings
  428.  
  429. =head1 SYNOPSIS
  430.  
  431.  use IO::String;
  432.  $io = IO::String->new;
  433.  $io = IO::String->new($var);
  434.  tie *IO, 'IO::String';
  435.  
  436.  # read data
  437.  <$io>;
  438.  $io->getline;
  439.  read($io, $buf, 100);
  440.  
  441.  # write data
  442.  print $io "string\n";
  443.  $io->print(@data);
  444.  syswrite($io, $buf, 100);
  445.  
  446.  select $io;
  447.  printf "Some text %s\n", $str;
  448.  
  449.  # seek
  450.  $pos = $io->getpos;
  451.  $io->setpos(0);        # rewind
  452.  $io->seek(-30, -1);
  453.  seek($io, 0, 0);
  454.  
  455. =head1 DESCRIPTION
  456.  
  457. The C<IO::String> module provides the C<IO::File> interface for in-core
  458. strings.  An C<IO::String> object can be attached to a string, and
  459. makes it possible to use the normal file operations for reading or
  460. writing data, as well as for seeking to various locations of the string.
  461. This is useful when you want to use a library module that only
  462. provides an interface to file handles on data that you have in a string
  463. variable.
  464.  
  465. Note that perl-5.8 and better has built-in support for "in memory"
  466. files, which are set up by passing a reference instead of a filename
  467. to the open() call. The reason for using this module is that it
  468. makes the code backwards compatible with older versions of Perl.
  469.  
  470. The C<IO::String> module provides an interface compatible with
  471. C<IO::File> as distributed with F<IO-1.20>, but the following methods
  472. are not available: new_from_fd, fdopen, format_write,
  473. format_page_number, format_lines_per_page, format_lines_left,
  474. format_name, format_top_name.
  475.  
  476. The following methods are specific to the C<IO::String> class:
  477.  
  478. =over 4
  479.  
  480. =item $io = IO::String->new
  481.  
  482. =item $io = IO::String->new( $string )
  483.  
  484. The constructor returns a newly-created C<IO::String> object.  It
  485. takes an optional argument, which is the string to read from or write
  486. into.  If no $string argument is given, then an internal buffer
  487. (initially empty) is allocated.
  488.  
  489. The C<IO::String> object returned is tied to itself.  This means
  490. that you can use most Perl I/O built-ins on it too: readline, <>, getc,
  491. print, printf, syswrite, sysread, close.
  492.  
  493. =item $io->open
  494.  
  495. =item $io->open( $string )
  496.  
  497. Attaches an existing IO::String object to some other $string, or
  498. allocates a new internal buffer (if no argument is given).  The
  499. position is reset to 0.
  500.  
  501. =item $io->string_ref
  502.  
  503. Returns a reference to the string that is attached to
  504. the C<IO::String> object.  Most useful when you let the C<IO::String>
  505. create an internal buffer to write into.
  506.  
  507. =item $io->pad
  508.  
  509. =item $io->pad( $char )
  510.  
  511. Specifies the padding to use if
  512. the string is extended by either the seek() or truncate() methods.  It
  513. is a single character and defaults to "\0".
  514.  
  515. =item $io->pos
  516.  
  517. =item $io->pos( $newpos )
  518.  
  519. Yet another interface for reading and setting the current read/write
  520. position within the string (the normal getpos/setpos/tell/seek
  521. methods are also available).  The pos() method always returns the
  522. old position, and if you pass it an argument it sets the new
  523. position.
  524.  
  525. There is (deliberately) a difference between the setpos() and seek()
  526. methods in that seek() extends the string (with the specified
  527. padding) if you go to a location past the end, whereas setpos()
  528. just snaps back to the end.  If truncate() is used to extend the string,
  529. then it works as seek().
  530.  
  531. =back
  532.  
  533. =head1 BUGS
  534.  
  535. In Perl versions < 5.6, the TIEHANDLE interface was incomplete.
  536. If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will
  537. not do anything on an C<IO::String> handle.  See L<perltie> for
  538. details.
  539.  
  540. =head1 SEE ALSO
  541.  
  542. L<IO::File>, L<IO::Stringy>, L<perlfunc/open>
  543.  
  544. =head1 COPYRIGHT
  545.  
  546. Copyright 1998-2005 Gisle Aas.
  547.  
  548. This library is free software; you can redistribute it and/or
  549. modify it under the same terms as Perl itself.
  550.  
  551. =cut
  552.